home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
BMUG Revelations
/
BMUG Revelations.toast
/
Utilities
/
Network
/
Asynchronous Networking
/
ULACS.inc1.p
< prev
next >
Wrap
Text File
|
1990-12-21
|
95KB
|
3,415 lines
{$P}
{ ULACS.inc1.p }
{ Copyright © 1988 - 1990 Apple Computer, Inc. All rights reserved. }
var
gAboutWindow: TWindow; { About box window. }
gPssster: TPssst; { About box animation object. }
gADSP: integer; { Driver number for ADSP. }
{--------------------------------------------------------------------------------------------------}
{$S ARes}
function GetNow: longInt;
{ Return the current time (in seconds since 1904). }
var l: longInt;
begin
GetDateTime(l);
GetNow := l;
end;
function Expired(d: longInt): boolean;
{ Return true if this message is expired. Consider it expired also if it's positive or -1. Positive means
an expiration date earlier than 1968, which doesn't make sense any more, and eliminating them
avoids signed comparison problems. -1 used to be used for "kill" messages, but we've taken this
feature out, and this eliminates any old kill messages still floating around. }
begin
Expired := (d >= -1) or (d <= GetNow);
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
function LongAsString(l: longInt): Str255;
{ Convert a long into a string. }
var s: Str255;
begin
NumToString(l,s);
LongAsString := s;
end;
function BoolAsString(b: boolean): Str255;
{ Convert a boolean into a string. }
begin
if b then BoolAsString := 'true'
else BoolAsString := 'false';
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure PutNextString(var p: Ptr; var sz: longInt; s: Str255);
{ Store a string into a buffer, and append a tab (field separator). Increment the pointer and size as we go.
Note: the buffer must be large enough to hold the string without overflowing. }
begin
BlockMove(Ptr(ord4(@s)+1),p,length(s));
p := Ptr(ord4(p)+length(s));
p^ := kTab;
p := Ptr(ord4(p)+1);
sz := sz + length(s) + 1;
end;
procedure PutNextHandle(var p: Ptr; var sz: longInt; h: Handle);
{ Store a handle into a buffer, and append a tab (field separator). Increment the pointer and size as we go.
Note: the buffer must be large enough to hold the string without overflowing. }
var l: longInt;
begin
l := GetHandleSize(h);
BlockMove(h^,p,l);
p := Ptr(ord4(p)+l);
p^ := kTab;
p := Ptr(ord4(p)+1);
sz := sz + l + 1;
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
function BuildPull(p: Ptr): longInt;
{ Creat a pull command in the buffer pointed to by p. }
var sz: longInt;
begin
sz := 0;
PutNextString(p,sz,'Pull');
p^ := kReturn;
sz := sz+1;
BuildPull := sz;
end;
function BuildPullCold(p: Ptr): longInt;
{ Creat a pull cold command in the buffer pointed to by p. }
var sz: longInt;
begin
sz := 0;
PutNextString(p,sz,'PullCold');
p^ := kReturn;
sz := sz+1;
BuildPullCold := sz;
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
function TLACSApplication.DoMakeDocument(itsCmdNumber: CmdNumber): TDocument;
{ Make a new document. }
var messagesDoc: TLACSDocument;
begin
New(messagesDoc);
FailNil(messagesDoc);
messagesDoc.ILACSDocument;
DoMakeDocument := messagesDoc;
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
function TLACSApplication.DoMenuCommand(aCmdNumber: CmdNumber): TCommand;
{ Handle menu commands. }
var f: AppFile;
fInfo: FInfo;
ignore: OSErr;
procedure saveOne(d: TDocument);
{ Save a document. }
begin
d.Save(cSave,false,false);
end;
begin
DoMenuCommand := nil;
{ Check if we should pass the command on to the document (this is in case all windows are closed). }
if (aCmdNumber in
[cMessagesWindow,cNewWindow,cStatusWindow,cMarkAllRead,cClearMessages,cPreferences])
and (gDocList.fSize > 0) then
DoMenuCommand := TDocument(gDocList.At(1)).DoMenuCommand(aCmdNumber)
{ Otherwise, handle it locally if it's one of ours. }
else case aCmdNumber of
cAboutApp:
begin
{ Display the About... window and bring it to the front. }
gAboutWindow.Show(true,true);
gAboutWindow.Select;
end;
cFinderNew:
begin
{ Just started up. Make sure the settings file is there and ready for us. }
f.vRefnum := gConfiguration.sysVRefNum;
f.fName := GetString(kSettingsFileSTR)^^;
if GetFInfo(f.fName,f.vRefnum,fInfo) <> noErr then
begin
{ File not there, or weird in some way. Thwack it, and create a new one. }
ignore := FSDelete(f.fName,f.vRefnum);
ignore := Create(f.fName,f.vRefnum,kSignature,kLACSSettings);
end;
{ Open the settings file (DoRead'll take care of default values if the file was just created). }
OpenOld(cOpen,f);
end;
cQuit:
begin
{ Make sure we save everything first. }
gDocList.Each(saveOne);
{ Then let MacApp do it's normal quit stuff. }
DoMenuCommand := inherited DoMenuCommand(aCmdNumber);
end;
{ If it's not ours, let someone else handle it. }
otherwise DoMenuCommand := inherited DoMenuCommand(aCmdNumber);
end;
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TLACSApplication.DoSetupMenus;
{ Enable the appropriate menus. }
begin
inherited DoSetupMenus;
Enable(cAboutApp,true);
{ We need this just in case all the windows are closed. }
if gDocList.fSize > 0 then
begin
Enable(cMessagesWindow,true);
Enable(cNewWindow,true);
Enable(cStatusWindow,true);
Enable(cMarkAllRead,true);
Enable(cClearMessages,true);
Enable(cPreferences,true);
end;
end;
{--------------------------------------------------------------------------------------------------}
{$S AFields}
procedure TLACSApplication.Fields(procedure DoToField(fieldName: Str255; fieldAddr: Ptr;
fieldType: integer));
begin
DoToField('TLACSApplication', nil, bClass);
DoToField('gAboutWindow', @gAboutWindow, bObject);
DoToField('gPssster', @gPssster, bObject);
DoToField('gADSP', @gADSP, bInteger);
inherited Fields(DoToField);
end;
{--------------------------------------------------------------------------------------------------}
{$S AFree}
procedure TLACSApplication.Free;
begin
{ Free our periodic object that updates the "psssts"s. }
gPssster.Free;
inherited Free;
end;
{--------------------------------------------------------------------------------------------------}
{$S AInit}
procedure TLACSApplication.ILACSApplication(itsMainFileType: OSType);
var i: integer;
begin
IApplication(itsMainFileType);
{ Init the random number generator. }
GetDateTime(randSeed);
{ Set up the about box. }
new(gPssster);
FailNil(gPssster);
gPssster.IPeriodic(kPssstInitial,kPssstInactive,kPssstActive);
{ Init the network. }
if gConfiguration.atDrvrVersNum < 53 then { Check for AppleTalk phase 2. }
begin
StdAlert(phNoPhase2);
ExitMacApp;
end;
FailOSErr(OpenDriver('.MPP',i));
if OpenDriver('.DSP',gADSP) <> noErr then
begin
StdAlert(phNoADSP);
ExitMacApp;
end;
{ Set up the about box window. }
gAboutWindow := NewTemplateWindow(kAboutWindow,nil);
{ Suppress dead-stripping of the following classes }
if gDeadStripSuppression then
begin
if Member(TObject(nil), TMessagesWindow) then;
if Member(TObject(nil), TNewWindow) then;
if Member(TObject(nil), TStatusWindow) then;
if Member(TObject(nil), TWindow) then;
if Member(TObject(nil), TMessageListView) then;
end;
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TLACSApplication.Terminate;
{ Clean up when application is terminated. }
begin
{ Free all the documents. This is important since it'll force the net stuff to shut down. }
gDocList.FreeAll;
inherited Terminate;
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TLACSDocument.CheckFreeSpace;
{ Check the amount of free space available in memory, and free messages if necessary to make room. }
var hRes: Handle;
begin
{ Allocate our buffer zone. }
hRes := NewHandle(kOurMemReserve);
FailNil(hRes);
{ Free messages until we're down to safe(r) levels. }
while MemSpaceIsLow and (fMessages.fSize > 0) do fMessages.At(1).Free;
{ Dispose of the buffer area. }
DisposHandle(hRes);
end;
{--------------------------------------------------------------------------------------------------}
{$S AClose}
procedure TLACSDocument.CloseView(aView: TView);
{ Close a window in the document. }
begin
{ Ensure we close the window without closing the document. }
if aView.fDocument = self then aView.Close;
end;
{--------------------------------------------------------------------------------------------------}
{$S AOpen}
procedure TLACSDocument.DoInitialState;
{ Set up the initial state of the document. }
begin
with fConfig do
begin
{ These are the default algorithm parameters. }
inZoneSearch := 2;
push := true;
pull := false;
pullOnLess := 5;
count := true;
countValue := 30;
feedback := true;
delayBase := 5;
delayExp := 2;
expireIn := 345600; { 60*60*24*4 (four days) }
defaultFilter := kNormalFilter;
defaultType := kNormalType;
forwarding := kForwardManually;
signature := kSignatureFromChooser;
userSignature := '';
end;
fUseDisplayState := false;
end;
{--------------------------------------------------------------------------------------------------}
{$S AOpen}
procedure TLACSDocument.DoMakeViews(forPrinting: boolean);
{ Create views to display the document. }
var p: Point;
ds: TDocumentSaver;
re: TMessagesExpirator;
zl: TZoneLookup;
nl: TNodeLookup;
g: TGossip;
begin
{ Actually, we use this method mainly to start up the periodic functions. This isn't very MacAppish, but...
We need to have the windows around when reading in the document since we store some things
(like the total messages seen count) directly in fields in the window, but we don't want to have
periodic stuff going until everything else is fully set up. }
{ Document saver. }
new(ds);
FailNil(ds);
ds.IDocumentSaver(self,kDocSaverInitial,kDocSaverInactive,kDocSaverActive);
fDocumentSaver := ds;
{ Messages expirer. }
new(re);
FailNil(re);
re.IMessagesExpirator(self,kExpirerInitial,kExpirerInactive,kExpirerActive);
fMessagesExpirator := re;
{ Zone lookup. }
new(zl);
FailNil(zl);
zl.IZoneLookup(self,kZoneLookupInitial,kZoneLookupInactive,kZoneLookupActive);
fZoneLooker := zl;
{ Node lookup. }
new(nl);
FailNil(nl);
nl.INodeLookup(self,kNodeLookupInitial,kNodeLookupFastInactive,kNodeLookupSlowInactive,kNodeLookupActive);
fNodeLooker := nl;
{ Gossipee. }
new(g);
FailNil(g);
g.IGossip(self,false,kGossipeeInitial,kGossipeeInactive,kGossipeeActive);
fGossipee := g;
{ Gossiper. }
new(g);
FailNil(g);
g.IGossip(self,true,kGossiperInitial,kGossiperInactive,kGossiperActive);
fGossiper := g;
{ Set up windows according to the saved state. }
if fUseDisplayState then
begin
p := fDisplayState.messagesWindPos;
fMessagesWindow.Locate(p.h,p.v,false);
fMessagesWindow.fNotify.SetState(fDisplayState.notifyOnNew,false);
p := fDisplayState.newWindPos;
fNewWindow.Locate(p.h,p.v,false);
p := fDisplayState.statusWindPos;
fStatusWindow.Locate(p.h,p.v,false);
fStatusWindow.IncTotalMessages(fDisplayState.totalMessages);
fStatusWindow.IncTotalPassed(fDisplayState.passedMessages);
end;
{ Clear out any expired messages. }
fNewWindow.ResetExpire;
{ Start out bored. }
fStatusWindow.Bored;
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
function TLACSDocument.DoMenuCommand(aCmdNumber: CmdNumber): TCommand;
{ Handle menu commands. }
begin
DoMenuCommand := nil;
{ We only handle items in our menu. }
case aCmdNumber of
cMessagesWindow:
begin
{ Select it and bring it to the front. }
fMessagesWindow.Show(true,true);
fMessagesWindow.Select;
end;
cNewWindow:
begin
{ Select it and bring it to the front. }
fNewWindow.Show(true,true);
fNewWindow.Select;
end;
cStatusWindow:
begin
{ Select it and bring it to the front. }
fStatusWindow.Show(true,true);
fStatusWindow.Select;
end;
cMarkAllRead:
begin
{ Clear the current message display. }
fMessagesWindow.ClearCurrent;
{ Then mark everything as read. }
MarkAllAsRead;
end;
cClearMessages:
begin
{ Clear the current message display. }
fMessagesWindow.ClearCurrent;
{ Then delete all the messages. }
fMessages.FreeAll;
end;
cPreferences:
begin
{ Find out what the user would like as defaults. }
GetPreferences;
end;
{ If it's not ours, let someone else handle it. }
otherwise DoMenuCommand := inherited DoMenuCommand(aCmdNumber);
end;
end;
{--------------------------------------------------------------------------------------------------}
{$S AWriteFile}
procedure TLACSDocument.DoNeedDiskSpace(var dataForkBytes, rsrcForkBytes: longInt);
{ Computer how much disk space is needed to save the document to disk. }
procedure addInOne(r: TMessage);
{ Compute the space for one message. }
begin
r.DoNeedDiskSpace(dataForkBytes,rsrcForkBytes);
end;
begin
inherited DoNeedDiskSpace(dataForkBytes,rsrcForkBytes);
dataForkBytes := dataForkBytes + sizeof(longInt) + sizeof(DisplayState) + sizeof(ConfigSettings) +
sizeof(longInt) + fMessages.fSize;
fMessages.Each(addInOne);
end;
{--------------------------------------------------------------------------------------------------}
{$S AReadFile}
procedure TLACSDocument.DoRead(aRefNum: integer; rsrcExists, forPrinting: boolean);
{ Read the document from disk. }
var dispRec: DisplayState;
fileFormat: longInt;
errRet: OSErr;
nr: TMessage;
l: longInt;
n: longInt;
i: longInt;
s: longInt;
h: Handle;
config: ConfigSettings;
begin
{ Get the file size. }
FailOSErr(GetEOF(aRefNum,l));
{ If it's zero, don't try to read it. }
if l = 0 then errRet := -1
else
begin
{ Otherwise, check the file format. }
l := sizeof(fileFormat);
errRet := FSRead(aRefNum,l,@fileFormat);
if (errRet = noErr) and (fileFormat <> kSettingsVersion) then
begin
{ If it's not what we're willing to parse, ask if we can erase it. }
if MacAppAlert(phInvalidSettings,nil) <> kYesButton then Failure(-1,0);
errRet := -1;
end;
end;
{ If we don't have a good settings file, initialize from scratch. }
if errRet <> noErr then
begin
{ Show the disclaimers. }
StdAlert(phLegal);
DoInitialState;
end
{ Otherwise, read it in from the file. }
else
begin
inherited DoRead(aRefNum,rsrcExists,forPrinting);
{ Read the display state. }
l := sizeof(dispRec);
FailOSErr(FSRead(aRefNum,l,@dispRec));
fDisplayState := dispRec;
fUseDisplayState := true;
{ Read the configuration. }
l := sizeof(config);
FailOSErr(FSRead(aRefNum,l,@config));
fConfig := config;
{ Read each of the messages. }
l := sizeof(n);
FailOSErr(FSRead(aRefNum,l,@n));
for i := 1 to n do
begin
new(nr);
FailNil(nr);
nr.IMessageFromFile(self,aRefNum);
end;
end;
{ Now expire any messages that need it. }
ExpireMessages;
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TLACSDocument.DoSetupMenus;
{ Enable the appropriate menus. }
begin
inherited DoSetupMenus;
Enable(cMessagesWindow,true);
Enable(cNewWindow,true);
Enable(cStatusWindow,true);
Enable(cMarkAllRead,true);
Enable(cClearMessages,true);
Enable(cPreferences,true);
end;
{--------------------------------------------------------------------------------------------------}
{$S AWriteFile}
procedure TLACSDocument.DoWrite(aRefNum: integer; makingCopy: boolean);
{ Write the document to disk. }
var dispRec: DisplayState;
fileFormat: longInt;
errRet: OSErr;
sr: SavedMessage;
l: longInt;
n: longInt;
i: longInt;
s: longInt;
h: Handle;
r: Rect;
config: ConfigSettings;
procedure saveOne(r: TMessage);
{ Write one message to disk. }
begin
r.WriteToFile(aRefNum);
end;
begin
{ Write file format. }
fileFormat := kSettingsVersion;
l := sizeof(fileFormat);
FailOSErr(FSWrite(aRefNum,l,@fileFormat));
inherited DoWrite(aRefNum,makingCopy);
{ Figure out the display state. }
with dispRec do
begin
fMessagesWindow.GetGlobalBounds(r);
messagesWindPos := r.topLeft;
messagesWindShown := fMessagesWindow.IsShown;
notifyOnNew := fMessagesWindow.fNotify.IsOn;
fNewWindow.GetGlobalBounds(r);
newWindPos := r.topLeft;
newWindShown := fNewWindow.IsShown;
fStatusWindow.GetGlobalBounds(r);
statusWindPos := r.topLeft;
statusWindShown := fStatusWindow.IsShown;
totalMessages := fStatusWindow.fTotalMessages.GetValue;
passedMessages := fStatusWindow.fTotalPassed.GetValue;
end;
{ Write the display state. }
l := sizeof(dispRec);
FailOSErr(FSWrite(aRefNum,l,@dispRec));
{ Write the configuration. }
config := fConfig;
l := sizeof(config);
FailOSErr(FSWrite(aRefNum,l,@config));
{ Write the message count. }
n := fMessages.fSize;
l := sizeof(n);
FailOSErr(FSWrite(aRefNum,l,@n));
{ Write the messages. }
fMessages.Each(saveOne);
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TLACSDocument.ExpireMessages;
{ Check for expired messages, and dump them if they are expired. }
procedure expireOne(r: TMessage);
{ Check one message. }
begin
if Expired(r.fExpireDate) then r.Free;
end;
begin
fMessages.Each(expireOne);
end;
{--------------------------------------------------------------------------------------------------}
{$S AFields}
procedure TLACSDocument.Fields(procedure DoToField(fieldName: Str255; fieldAddr: Ptr;
fieldType: integer));
var s: Str255;
begin
DoToField('TLACSDocument', nil, bClass);
DoToField('fMessages', @fMessages, bObject);
DoToField('fMessagesWindow', @fMessagesWindow, bObject);
DoToField('fNewWindow', @fNewWindow, bObject);
DoToField('fStatusWindow', @fStatusWindow, bObject);
DoToField('fDocumentSaver', @fDocumentSaver, bObject);
DoToField('fMessagesExpirator', @fMessagesExpirator, bObject);
DoToField('fZoneLooker', @fZoneLooker, bObject);
DoToField('fNodeLooker', @fNodeLooker, bObject);
DoToField('fGossiper', @fGossiper, bObject);
DoToField('fGossipee', @fGossipee, bObject);
DoToField('fConfig.inZoneSearch', @fConfig.inZoneSearch, bInteger);
DoToField('fConfig.push', @fConfig.push, bBoolean);
DoToField('fConfig.pull', @fConfig.pull, bBoolean);
DoToField('fConfig.pullOnLess', @fConfig.pullOnLess, bInteger);
DoToField('fConfig.count', @fConfig.count, bBoolean);
DoToField('fConfig.countValue', @fConfig.countValue, bInteger);
DoToField('fConfig.feedback', @fConfig.feedback, bBoolean);
DoToField('fConfig.delayBase', @fConfig.delayBase, bLongInt);
DoToField('fConfig.delayExp', @fConfig.delayExp, bLongInt);
DoToField('fConfig.expireIn', @fConfig.expireIn, bLongInt);
DoToField('fConfig.defaultFilter', @fConfig.defaultFilter, bString);
DoToField('fConfig.defaultType', @fConfig.defaultType, bString);
case fConfig.forwarding of
kForwardManually: s := 'kForwardManually';
kForwardIfSigned: s := 'kForwardIfSigned';
kForwardAlways: s := 'kForwardAlways';
end;
DoToField('fConfig.forwarding', @s, bString);
case fConfig.signature of
kNoSignature: s := 'kNoSignature';
kSignatureFromChooser: s := 'kSignatureFromChooser';
kSignatureFromUser: s := 'kSignatureFromUser';
end;
DoToField('fConfig.signature', @s, bString);
DoToField('fConfig.userSignature', @fConfig.userSignature, bString);
DoToField('fUseDisplayState', @fUseDisplayState, bBoolean);
DoToField('fDisplayState.messagesWindPos', @fDisplayState.messagesWindPos, bPoint);
DoToField('fDisplayState.messagesWindShown', @fDisplayState.messagesWindShown, bBoolean);
DoToField('fDisplayState.notifyOnNew', @fDisplayState.notifyOnNew, bBoolean);
DoToField('fDisplayState.newWindPos', @fDisplayState.newWindPos, bPoint);
DoToField('fDisplayState.newWindShown', @fDisplayState.newWindShown, bBoolean);
DoToField('fDisplayState.statusWindPos', @fDisplayState.statusWindPos, bPoint);
DoToField('fDisplayState.statusWindShown', @fDisplayState.statusWindShown, bBoolean);
DoToField('fDisplayState.totalMessages', @fDisplayState.totalMessages, bLongInt);
DoToField('fDisplayState.passedMessages', @fDisplayState.passedMessages, bLongInt);
inherited Fields(DoToField);
end;
{--------------------------------------------------------------------------------------------------}
{$S AFree}
procedure TLACSDocument.Free;
{ Free the document. }
var ignore: OSErr;
begin
{ Free all the messages, and the list itself. }
fMessages.FreeList;
{ Free the periodic objects. }
FreeIfObject(fDocumentSaver);
FreeIfObject(fMessagesExpirator);
FreeIfObject(fZoneLooker);
FreeIfObject(fNodeLooker);
FreeIfObject(fGossiper);
FreeIfObject(fGossipee);
{ Free the windows. }
FreeIfObject(fMessagesWindow);
FreeIfObject(fNewWindow);
FreeIfObject(fStatusWindow);
inherited Free;
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
function TLACSDocument.GetHotMessage: TMessage;
{ Find a hot message, if there are any. }
var hotness: integer;
procedure checkForHot(r: TMessage);
{ Check the temperature of a message. }
begin
if r.IsHot and r.fForward then
if (r.fBadPasses + r.fSuccessfulPasses) < hotness then
begin
GetHotMessage := r;
hotness := r.fBadPasses + r.fSuccessfulPasses;
end;
end;
begin
{ Find the hotest message there is. }
hotness := 32000;
GetHotMessage := nil;
fMessages.Each(checkForHot);
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TLACSDocument.GetPreferences;
{ Query the user for his preferences. }
var aWindow: TWindow;
forwMan, forwSig, forwAll: TRadio;
sigNone, sigChooser, sigUser: TRadio;
sig: TEditText;
s: Str255;
begin
{ Get the dialog window. }
aWindow := NewTemplateWindow(kPreferencesWindow, NIL);
FailNIL(aWindow);
{ Find all the radio buttons and the TEditText. }
forwMan := TRadio(aWindow.FindSubView('Manu'));
forwSig := TRadio(aWindow.FindSubView('Auts'));
forwAll := TRadio(aWindow.FindSubView('Auta'));
sigNone := TRadio(aWindow.FindSubView('Nosi'));
sigChooser := TRadio(aWindow.FindSubView('Sigc'));
sigUser := TRadio(aWindow.FindSubView('Sigu'));
sig := TEditText(aWindow.FindSubView('Sign'));
{ Set them to the current configuration. }
forwMan.SetState(fConfig.forwarding = kForwardManually,false);
forwSig.SetState(fConfig.forwarding = kForwardIfSigned,false);
forwAll.SetState(fConfig.forwarding = kForwardAlways,false);
sigNone.SetState(fConfig.signature = kNoSignature,false);
sigChooser.SetState(fConfig.signature = kSignatureFromChooser,false);
sigUser.SetState(fConfig.signature = kSignatureFromUser,false);
s := fConfig.userSignature;
sig.SetText(s,false);
{ Query the user, but only listen to the result if the user clicks on OK. }
if TDialogView(aWindow.FindSubView('DLOG')).PoseModally = 'OKOK' then
begin
{ Record the new configuration. }
if forwMan.IsOn then fConfig.forwarding := kForwardManually
else if forwSig.IsOn then fConfig.forwarding := kForwardIfSigned
else if forwAll.IsOn then fConfig.forwarding := kForwardAlways;
if sigNone.IsOn then fConfig.signature := kNoSignature
else if sigChooser.IsOn then fConfig.signature := kSignatureFromChooser
else if sigUser.IsOn then fConfig.signature := kSignatureFromUser;
sig.GetText(s);
fConfig.userSignature := s;
fNewWindow.GetSignature;
end;
{ Close the window and release it. }
aWindow.Close;
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
function TLACSDocument.GetRandomMessage: TMessage;
{ Find a message at random. }
begin
if fMessages.fSize <= 0 then GetRandomMessage := nil
else GetRandomMessage := TMessage(fMessages.At(abs(Random) mod fMessages.fSize + 1));
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
function TLACSDocument.GetMessage(f: Str32; t: Str32; h: Handle): TMessage;
{ Get the message that corresponds to the filter/type/handle given. }
function eqMessage(r: TMessage): boolean;
{ Check if this is the message we're looking for. }
var p1, p2: Ptr;
sz: longInt;
begin
eqMessage := false;
{ Does it have the same type and filter? }
if (f = r.fFilter) and (t = r.fType) then
begin
{ Does it have the same text? }
sz := GetHandleSize(h);
if sz = GetHandleSize(r.fText) then
begin
p1 := h^; p2 := r.fText^;
while sz > 0 do
begin
if p1^ <> p2^ then exit(eqMessage);
p1 := Ptr(ord4(p1)+1);
p2 := Ptr(ord4(p2)+1);
sz := sz-1;
end;
eqMessage := true;
end;
end;
end;
begin
GetMessage := TMessage(fMessages.FirstThat(eqMessage));
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
function TLACSDocument.HandleIncomingCommand(theData: Ptr; theSz: longInt): longInt;
{ Handle an incoming command. If there's a reply, put it into the same buffer and return the size. }
var p: Ptr;
h: Handle;
cmd: Str255;
messageFilter: Str255;
messageType: Str255;
sd: longInt;
ed: longInt;
i: integer;
sz: longInt;
answerSz: longInt;
r: TMessage;
procedure getNextString(var p: Ptr; var sz: longInt; var s: Str255; maxSize: integer);
{ Get the next string in the command. }
var i: integer;
pStart: Ptr;
begin
i := 0;
pStart := p;
while (sz > 0) and (p^ <> kTab) do
begin
p := Ptr(ord4(p)+1);
sz := sz-1;
if i < maxSize then i := i+1;
end;
s[0] := chr(i);
BlockMove(pStart,Ptr(ord4(@s)+1),i);
while (sz > 0) and (p^ <> kTab) do
begin
p := Ptr(ord4(p)+1);
sz := sz-1;
end;
if sz > 0 then
begin
p := Ptr(ord4(p)+1);
sz := sz-1;
end;
end;
function getNextHandle(var p: Ptr; var sz: longInt; maxSize: longInt): Handle;
{ Get the next handle (indefinite length string) in the command. }
var pStart: Ptr;
szToGet: longInt;
begin
pStart := p;
while (sz > 0) and (p^ <> kTab) do
begin
p := Ptr(ord4(p)+1);
sz := sz-1;
end;
szToGet := ord4(p)-ord4(pStart);
if szToGet > maxSize then szToGet := maxSize;
h := NewHandle(szToGet);
if h <> nil then BlockMove(pStart,h^,szToGet);
if p^ = kTab then
begin
p := Ptr(ord4(p)+1);
sz := sz-1;
end;
getNextHandle := h;
end;
function getNextLong(var p: Ptr; var sz: longInt): longInt;
{ Get the next longInt in the command. }
var s: Str255;
l: longInt;
begin
getNextString(p,sz,s,255);
StringToNum(s,l);
getNextLong := l;
end;
begin
sz := theSz;
answerSz := 0;
p := theData;
h := nil;
{ Get the command. }
getNextString(p,sz,cmd,255);
{ Check for a new message command. }
if cmd = 'Rumor' then
begin
{ Get the message. }
getNextString(p,sz,messageFilter,32);
getNextString(p,sz,messageType,32);
h := getNextHandle(p,sz,kMaxMessageSize);
if h <> nil then
begin
sd := getNextLong(p,sz);
if sd = 0 then sd := GetNow;
ed := getNextLong(p,sz);
{ Have we heard it? }
r := GetMessage(messageFilter,messageType,h);
{ If yes, then reply that it's cold. }
if r <> nil then cmd := 'ColdRumor'
{ Otherwise remember it and reply that it's hot. }
else
begin
NewMessage(false,messageFilter,messageType,h,sd,ed,false);
cmd := 'HotRumor';
end;
{ Build our answer. }
PutNextString(theData,answerSz,cmd);
PutNextString(theData,answerSz,messageFilter);
PutNextString(theData,answerSz,messageType);
PutNextHandle(theData,answerSz,h);
end;
end
{ Check for cold message reply. }
else if cmd = 'ColdRumor' then
begin
{ Get the message. }
getNextString(p,sz,messageFilter,32);
getNextString(p,sz,messageType,32);
h := getNextHandle(p,sz,kMaxMessageSize);
{ Find it and cool it off. }
r := GetMessage(messageFilter,messageType,h);
if r <> nil then r.FailedPass;
end
{ Check for hot message reply. }
else if cmd = 'HotRumor' then
begin
{ Get the message. }
getNextString(p,sz,messageFilter,32);
getNextString(p,sz,messageType,32);
h := getNextHandle(p,sz,kMaxMessageSize);
{ Find it and warm it up. }
r := GetMessage(messageFilter,messageType,h);
if r <> nil then r.SuccessfullPass;
end
{ Check for a dump our parameters command. }
else if cmd = 'DumpParams' then
begin
{ Build a reply telling what our parameters are. }
PutNextString(theData,answerSz,'Params');
PutNextString(theData,answerSz,Concat(
'Version ',kApplicationVersion,
'InZoneSearch ',LongAsString(fConfig.inZoneSearch),
' Push ',BoolAsString(fConfig.push),
' Pull ',BoolAsString(fConfig.pull),
' PullOnLess ',LongAsString(fConfig.pullOnLess),
' Count ',BoolAsString(fConfig.count),
' CountValue ',LongAsString(fConfig.countValue),
' Feedback ',BoolAsString(fConfig.feedback),
' DelayBase ',LongAsString(fConfig.delayBase),
' DelayExp ',LongAsString(fConfig.delayExp)));
end
{ Check for a pull command. }
else if cmd = 'Pull' then
begin
{ Get a message and return it. }
r := GetHotMessage;
if r <> nil then answerSz := r.BuildMessageCommand(theData);
end
{ Check for a pull-even-if-it's-cold command. }
else if cmd = 'PullCold' then
begin
{ Get a message, any message, and return it. }
r := GetHotMessage;
if r = nil then r := GetRandomMessage;
if r <> nil then
if not r.fForward then r := nil;
if r <> nil then answerSz := r.BuildMessageCommand(theData);
end;
{ If we've built a reply, terminate it with the return. }
if answerSz > 0 then
begin
theData^ := kReturn;
answerSz := answerSz+1;
end;
if h <> nil then DisposHandle(h);
HandleIncomingCommand := answerSz;
end;
{--------------------------------------------------------------------------------------------------}
{$S AInit}
procedure TLACSDocument.ILACSDocument;
{ Intialize the document. }
begin
IDocument(kLACSSettings, kSignature, kUsesDataFork, NOT kUsesRsrcFork, kDataOpen, NOT kRsrcOpen);
{ We make the windows here instead of in DoMakeView/Windows because we keep some of the model
information in window objects, so we need them around when we're reading in the document. }
fMessagesWindow := TMessagesWindow(NewTemplateWindow(kMessagesWindow,self));
fMessagesWindow.FindSubviews;
fNewWindow := TNewWindow(NewTemplateWindow(kNewWindow,self));
fNewWindow.FindSubviews;
fStatusWindow := TStatusWindow(NewTemplateWindow(kStatusWindow,self));
fStatusWindow.FindSubviews;
{ Clear out the periodic functions. }
fDocumentSaver := nil;
fMessagesExpirator := nil;
fZoneLooker := nil;
fNodeLooker := nil;
fGossiper := nil;
fGossipee := nil;
{ Init the message list. }
fMessages := NewList;
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TLACSDocument.MarkAllAsRead;
{ Mark all messages as read. }
procedure markOne(r: TMessage);
{ Mark one message as read. }
begin
r.MarkAsRead;
end;
begin
fMessagesWindow.fUnread.Each(markOne);
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TLACSDocument.NewMessage(ru: boolean; f: Str32; t: Str32; h: Handle; sd: longInt; ed: longInt;
alwaysForward: boolean);
{ Enter a new message into the document. }
var nr: TMessage;
begin
{ Only record it is it hasn't already expired. }
if (not Expired(ed)) and (GetHandleSize(h) > 0) then
begin
{ Notify the user. }
fMessagesWindow.Notify;
fStatusWindow.SetStatus(kStatNewMessage);
{ Create the message. }
new(nr);
FailNil(nr);
nr.IMessage(self, ru, f, t, h, sd, ed);
if alwaysForward then nr.fForward := true;
fStatusWindow.IncTotalMessages(1);
{ Get the gossiper moving if he isn't already. }
fGossiper.Kick;
end;
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TLACSDocument.ParseAsParams(h: Handle);
{ Interpret the data in the handle as a configuration setting string. }
var p: Ptr;
sz: longInt;
s: Str255;
procedure nextWord;
{ Return the next word in the input. }
var strt: Ptr;
l: longInt;
begin
while p^ = ord(' ') do
begin
p := Ptr(ord4(p)+1);
sz := sz-1;
end;
strt := p;
while (sz > 0) and (p^ <> ord(' ')) do
begin
p := Ptr(ord4(p)+1);
sz := sz-1;
end;
l := ord4(p)-ord4(strt);
if l > 255 then l := 255;
s[0] := chr(l);
BlockMove(strt,Ptr(ord4(@s)+1),l);
end;
function nextInt: integer;
{ Return the next longInt in the input. }
var l: longInt;
begin
nextWord;
StringToNum(s,l);
nextInt := l;
end;
function nextBool: boolean;
{ Return the next boolean in the input. }
begin
nextWord;
nextBool := s = 'true';
end;
begin
{ Cycle through the input, settings parameters as indicated. }
p := h^;
sz := GetHandleSize(h);
while sz > 0 do
begin
nextWord;
if s = 'InZoneSearch' then fConfig.inZoneSearch := nextInt
else if s = 'Push' then fConfig.push := nextBool
else if s = 'Pull' then fConfig.pull := nextBool
else if s = 'PullOnLess' then fConfig.pullOnLess := nextInt
else if s = 'Count' then fConfig.count := nextBool
else if s = 'CountValue' then fConfig.countValue := nextInt
else if s = 'Feedback' then fConfig.feedback := nextBool
else if s = 'DelayBase' then fConfig.delayBase := nextInt
else if s = 'DelayExp' then fConfig.delayExp := nextInt
else nextWord;
end;
end;
{--------------------------------------------------------------------------------------------------}
{$S AOpen}
procedure TLACSDocument.ShowWindows;
{ Display windows (or not) as appropriate. }
begin
{ First, make sure we've got our memory allocation in hand. }
CheckFreeSpace;
{ Calculate the current signature. }
fNewWindow.GetSignature;
{Open up the windows. }
fStatusWindow.Open;
fNewWindow.Open;
fMessagesWindow.Open;
if fUseDisplayState then
begin
if fDisplayState.statusWindShown then fStatusWindow.Select
else fStatusWindow.Show(false,false);
if fDisplayState.newWindShown then fNewWindow.Select
else fNewWindow.Show(false,false);
if fDisplayState.messagesWindShown then fMessagesWindow.Select
else fMessagesWindow.Show(false,false);
end
else
begin
fStatusWindow.Select;
fNewWindow.Select;
fMessagesWindow.Select;
end;
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TMessage.AsString(var aString: Str255);
{ Return a string that represents the message (for display lists). }
var h: Handle;
l: longInt;
begin
h := fText;
{ Figure out the size. }
l := GetHandleSize(h)+2;
if l > 255 then l := 255;
aString[0] := chr(l);
{ Mark it as hot or cold. }
if fHot then aString[1] := '◊'
else aString[1] := ' ';
aString[2] := ' ';
{ Fill in the text. }
BlockMove(h^,Ptr(ord4(@aString)+3),l-2);
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
function TMessage.BuildMessageCommand(var theData: Ptr): longInt;
{ Build a message command into the buffer pointed to by theData, incrementing theData as we go,
and return the size of the command built. }
var sz: longInt;
t, f: Str32;
begin
sz := 0;
{ Put in command name. }
PutNextString(theData,sz,'Rumor');
{ Put in parameters. }
f := fFilter;
PutNextString(theData,sz,f);
t := fType;
PutNextString(theData,sz,t);
PutNextHandle(theData,sz,fText);
PutNextString(theData,sz,LongAsString(fStartDate));
PutNextString(theData,sz,LongAsString(fExpireDate));
{ Terminate it with a return. }
theData^ := kReturn;
sz := sz+1;
buildMessageCommand := sz;
end;
{--------------------------------------------------------------------------------------------------}
{$S AWriteFile}
procedure TMessage.DoNeedDiskSpace(var dataForkBytes, rsrcForkBytes: longInt);
{ Return the amount of disk space needed to save this message. }
begin
dataForkBytes := dataForkBytes + sizeof(SavedMessage) + sizeof(longInt) + GetHandleSize(fText);
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TMessage.FailedPass;
{ Factor in one more bad pass attempt. }
begin
fBadPasses := fBadPasses+1;
UpdateHotness;
end;
{--------------------------------------------------------------------------------------------------}
{$S AFields}
procedure TMessage.Fields(procedure DoToField(fieldName: Str255; fieldAddr: Ptr;
fieldType: integer));
begin
DoToField('TMessage', nil, bClass);
DoToField('fDocument', @fDocument, bObject);
DoToField('fHot', @fHot, bBoolean);
DoToField('fSuccessfulPasses', @fSuccessfulPasses, bInteger);
DoToField('fBadPasses', @fBadPasses, bInteger);
DoToField('fFilter', @fFilter, bString);
DoToField('fType', @fType, bString);
DoToField('fText', @fText, bHandle);
DoToField('fStartDate', @fStartDate, bLongInt);
DoToField('fExpireDate', @fExpireDate, bLongInt);
DoToField('fLastMessaged', @fLastMessaged, bLongInt);
DoToField('fForward', @fForward, bBoolean);
inherited Fields(DoToField);
end;
{--------------------------------------------------------------------------------------------------}
{$S AFree}
procedure TMessage.Free;
{ Free the message object. }
begin
{ Get us out of the main message list. }
fDocument.fMessages.Delete(self);
{ And out of the display lists. }
fDocument.fMessagesWindow.fUnread.Delete(self);
fDocument.fMessagesWindow.fRead.Delete(self);
{ Factor us out of the hot/cold statistics. }
if fHot then fDocument.fStatusWindow.IncHotMessages(-1)
else fDocument.fStatusWindow.IncColdMessages(-1);
{ Dispose of the body. }
DisposHandle(fText);
{ Dispose of everything else. }
inherited Free;
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TMessage.IMessage(aDoc: TLACSDocument; isRead: boolean; f: Str32; t: Str32; newText: Handle; sd: longInt; ed: longInt);
{ Initialize a message object. }
var h: Handle;
p: Ptr;
sz: longInt;
function containsSignature: boolean;
var p: Ptr;
sz: longInt;
begin
containsSignature := false;
p := newText^;
sz := GetHandleSize(newText);
while sz > 0 do
begin
if p^ = ord(kSignatureSeparator) then
begin
containsSignature := true;
leave;
end;
p := Ptr(ord4(p)+1);
sz := sz-1;
end;
end;
begin
IObject;
{ Remember the document we're attached to. }
fDocument := aDoc;
{ Duplicate the body of the message. }
h := newText;
if HandToHand(h) <> noErr then h := NewHandle(0);
FailNil(h);
if GetHandleSize(h) > kMaxMessageSize then SetHandleSize(h,kMaxMessageSize);
{ Eliminate any tabs or returns from it (they shouldn't be there anyway, but we're paranoid. }
p := h^;
sz := GetHandleSize(h);
while sz > 0 do
begin
if (p^ = kTab) or (p^ = kReturn) then p^ := ord(' ');
p := Ptr(ord4(p)+1);
sz := sz-1;
end;
{ Insert ourselves into the main message list. }
aDoc.fMessages.InsertLast(self);
{ Start out hot. }
fHot := true;
aDoc.fStatusWindow.IncHotMessages(1);
{ Start out unpassed. }
fSuccessfulPasses := 0;
fBadPasses := 0;
{ Remember the filter, type, body, and dates. }
fFilter := f;
fType := t;
fText := h;
fStartDate := sd;
fExpireDate := ed;
{ Start remessage timer. }
fLastMessaged := GetNow;
{ Decide how to forward. }
if aDoc.fConfig.forwarding = kForwardManually then fForward := false;
if aDoc.fConfig.forwarding = kForwardAlways then fForward := true
else fForward := containsSignature;
{ Decide if we should display the message for the user. }
if f = aDoc.fConfig.defaultFilter then
begin
{ If yes, then display it in one of the two lists: read or unread. }
if isRead then aDoc.fMessagesWindow.fRead.Insert(self)
else aDoc.fMessagesWindow.fUnread.Insert(self);
end;
{ If this is a parameter message, then process the parameters. }
if t = 'Params' then ParseAsParams;
{ Tweak our free space. }
aDoc.CheckFreeSpace;
end;
{--------------------------------------------------------------------------------------------------}
{$S AReadFile}
procedure TMessage.IMessageFromFile(aDoc: TLACSDocument; aRefNum: integer);
{ Initialize a message object from a file. }
var sr: SavedMessage;
l: longInt;
s: longInt;
h: Handle;
begin
{ Get the saved message info (everything but the body). }
l := sizeof(sr);
FailOSErr(FSRead(aRefNum,l,@sr));
{ Get the size of the body. }
l := sizeof(s);
FailOSERR(FSRead(aRefNum,l,@s));
{ Allocate and read the body of the message. }
h := NewHandle(s);
FailNil(h);
HLock(h);
FailOSErr(FSRead(aRefNum,s,h^));
HUnlock(h);
{ Initialize the message. }
IMessage(aDoc, sr.inReadList, sr.filter, sr.rType, h, sr.startDate, sr.expireDate);
{ Set it's hotness, passes, and last messaged fields. }
fHot := sr.hot;
if not sr.hot then
begin
aDoc.fStatusWindow.IncHotMessages(-1);
aDoc.fStatusWindow.IncColdMessages(1);
end;
fSuccessfulPasses := sr.successfulPasses;
fBadPasses := sr.badPasses;
fLastMessaged := sr.lastMessaged;
fForward := sr.forward;
{ Free our copy of the body (IMessage makes its own copy). }
DisposHandle(h);
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
function TMessage.IsHot: boolean;
{ Return true if this message is still hot, and if enough time has passed for it to be spread again. }
var l: longInt;
age: longInt;
begin
{ Assume it's not hot. }
IsHot := false;
{ First off, it must actually be hot. }
if fHot then
begin
{ Second, enough time must have passed. }
age := fDocument.fConfig.delayBase * fBadPasses;
for l := 1 to fDocument.fConfig.delayExp-1 do age := age * fDocument.fConfig.delayBase * fBadPasses;
if GetNow > (fLastMessaged + age) then IsHot := true;
end;
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TMessage.MarkAsRead;
{ Mark this message as read. }
begin
{ Take it out of the unread list. }
fDocument.fMessagesWindow.fUnread.Delete(self);
{ Put it into the read list, if it isn't already there. }
if fDocument.fMessagesWindow.fRead.GetSameItemNo(self) = kEmptyIndex then
fDocument.fMessagesWindow.fRead.Insert(self);
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TMessage.ParseAsParams;
{ Parse ourself as algorithm parameters. }
begin
{ Just let the document do all the work. }
fDocument.ParseAsParams(fText);
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TMessage.SuccessfullPass;
{ Factor in one more successfull pass. }
begin
fDocument.fStatusWindow.IncTotalPassed(1);
fSuccessfulPasses := fSuccessfulPasses+1;
UpdateHotness;
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TMessage.UpdateHotness;
{ Update the temperature of this message. }
var bad: integer;
begin
{ Update when we last messaged -- this is only called after a message attempt. }
fLastMessaged := GetNow;
{ If we're hot now, see if we've cooled off. }
if fHot then
begin
{ Figure out how many bad passes we think there's been. }
bad := fBadPasses;
{ If we're not using feedback, then count successfull passes as bad. }
if not fDocument.fConfig.feedback then bad := bad + fSuccessfulPasses;
{ Deterministic? }
if fDocument.fConfig.count then
begin
if bad > fDocument.fConfig.countValue then fHot := false;
end
{ ... or statictical? }
else
begin
if (abs(Random) mod fDocument.fConfig.countValue) = 0 then fHot := false;
end;
{ If we've cooled off, then update the lists and the statistics. }
if not fHot then
begin
fDocument.fMessagesWindow.fUnread.Invalidate(self);
fDocument.fMessagesWindow.fRead.Invalidate(self);
fDocument.fStatusWindow.IncHotMessages(-1);
fDocument.fStatusWindow.IncColdMessages(1);
end;
end;
end;
{--------------------------------------------------------------------------------------------------}
{$S AWriteFile}
procedure TMessage.WriteToFile(aRefNum: integer);
{ Save this message to disk. }
var sr: SavedMessage;
l: longInt;
n: longInt;
h: Handle;
fi: FailInfo;
procedure hdlFailure(error: OSErr; message: LongInt);
{ If we fail, unlock the handle. }
begin
HUnlock(h);
end;
begin
{ Fill in the non-body part of the save. }
with sr do
begin
hot := fHot;
successfulPasses := fSuccessfulPasses;
badPasses := fBadPasses;
filter := fFilter;
rType := fType;
startDate := fStartDate;
expireDate := fExpireDate;
lastMessaged := fLastMessaged;
forward := fForward;
inReadList := fDocument.fMessagesWindow.fRead.GetSameItemNo(self) <> kEmptyIndex;
end;
{ Save it. }
l := sizeof(sr);
FailOSErr(FSWrite(aRefNum,l,@sr));
{ Write the size of the body. }
l := sizeof(n);
h := fText;
n := GetHandleSize(h);
FailOSERR(FSWrite(aRefNum,l,@n));
{ Write the body itself. }
HLock(h);
CatchFailures(fi,hdlFailure);
FailOSErr(FSWrite(aRefNum,n,h^));
Success(fi);
HUnlock(h);
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TDisplayList.AtDelete(index: ArrayIndex);
{ Delete the entry at index. }
begin
{ If it's currently in the full display, clear that. }
if fView.IsItemSelected(index) then fDocument.fMessagesWindow.ClearCurrent;
{ Delete it from the displayed list. }
fView.DelItemAt(index,1);
{ Delete it from our list. }
inherited AtDelete(index);
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
function TDisplayList.Compare(item1, item2: TObject): CompareResult;
{ Compare two objects. }
begin
{ Compare by origination date. }
if TMessage(item1).fStartDate > TMessage(item2).fStartDate then Compare := kItem1GreaterThanItem2
else if TMessage(item1).fStartDate < TMessage(item2).fStartDate then Compare := kItem1LessThanItem2
else Compare := kItem1EqualItem2;
end;
{--------------------------------------------------------------------------------------------------}
{$S AFields}
procedure TDisplayList.Fields(procedure DoToField(fieldName: Str255; fieldAddr: Ptr;
fieldType: integer)); override;
begin
DoToField('TDisplayList', nil, bClass);
DoToField('fDocument', @fDocument, bObject);
DoToField('fView', @fView, bObject);
inherited Fields(DoToField);
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TDisplayList.FreeAll;
{ Free everything. }
begin
{ Clear out the view. }
fView.DelItemFirst(fView.fNumOfRows);
{ Clear out the list. }
inherited FreeAll;
end;
{--------------------------------------------------------------------------------------------------}
{$S AInit}
procedure TDisplayList.IDisplayList(theDoc: TLACSDocument; theView: TMessageListView);
{ Initialize the list. }
begin
ISortedList;
fDocument := theDoc;
fView := theView;
theView.fList := self;
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TDisplayList.Insert(item: TObject);
{ Insert an item into the list. }
var index: ArrayIndex;
{$Push} {$IFC qTrace} {$D+} {$ENDC}
function TestItem(anItem: TObject): CompareResult;
begin
if qDebug then FailNonObject(anItem);
TestItem := Compare(item, anItem);
end;
{$Pop}
begin
if qDebug then FailNonObject(item);
if DoSearch(TestItem, index) <> nil then; { Discard result. }
InsertBefore(index, item);
fView.InsItemBefore(index,1);
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TDisplayList.Invalidate(o: TObject);
{ Invalidate the displayed object. }
var n: ArrayIndex;
begin
n := GetSameItemNo(o);
if n <> kEmptyIndex then fView.InvalidateItem(n);
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TDisplayList.Select(o: TObject);
{ Select the displayed object. }
begin
fView.SelectItem(GetSameItemNo(o),false,true,true);
fView.ScrollSelectionIntoView(true);
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TMessagesWindow.ClearCurrent;
{ Clear out the selected message display. }
begin
fRead.fView.SetEmptySelection(false);
fShow.SetText('');
fShow.ShowReverted;
fOriginated.SetText('',true);
fExpires.SetText('',true);
fForward.SetState(false,true);
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TMessagesWindow.DisplayMessage(r: TMessage);
{ Display message r. }
var h: Handle;
s, s2: Str255;
begin
{ Show the text body. }
h := r.fText;
FailOSErr(HandToHand(h));
fShow.StuffText(h);
fShow.ShowReverted;
{ Show the origination date. }
IUDateString(r.fStartDate,abbrevDate,s);
Delete(s,1,5);
IUTimeString(r.fStartDate,false,s2);
fOriginated.SetText(Concat(s,' ',s2),true);
{ Show the expiration date. }
IUDateString(r.fExpireDate,AbbrevDate,s);
Delete(s,1,5);
IUTimeString(r.fExpireDate,false,s2);
s := Concat(s,' ',s2);
fExpires.SetText(s,true);
fForward.SetState(r.fForward,true);
{ Select the line in the read message list. }
fRead.Select(r);
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TMessagesWindow.DoChoice(origView: TView; itsChoice: integer);
{ Handle button hits, etc. }
var ourDoc: TLACSDocument;
i: integer;
r: TMessage;
begin
{ Send Message? }
if origView = fForward then
begin
i := fRead.fView.FirstSelectedItem;
if i > 0 then r := TMessage(fRead.At(i));
if r <> nil then r.fForward := fForward.IsOn;
end
{ Otherwise, let the defaults have it. }
else inherited DoChoice(origView,itsChoice);
end;
{--------------------------------------------------------------------------------------------------}
{$S AFields}
procedure TMessagesWindow.Fields(procedure DoToField(fieldName: Str255; fieldAddr: Ptr;
fieldType: integer)); override;
begin
DoToField('TMessagesWindow', nil, bClass);
DoToField('fNotification', @fNotification, bPointer);
DoToField('fUnread', @fUnread, bObject);
DoToField('fNotify', @fNotify, bObject);
DoToField('fRead', @fRead, bObject);
DoToField('fShow', @fShow, bObject);
DoToField('fOriginated', @fOriginated, bObject);
DoToField('fExpires', @fExpires, bObject);
inherited Fields(DoToField);
end;
{--------------------------------------------------------------------------------------------------}
{$S AInit}
procedure TMessagesWindow.FindSubviews;
{ Lookup all our subviews for later. }
var dl: TDisplayList;
begin
fNotification := Pointer(NewPtr(sizeof(NMRec)));
FailNil(fNotification);
new(dl);
FailNil(dl);
dl.IDisplayList(TLACSDocument(fDocument),TMessageListView(FindSubView('Unre')));
dl.FreeAll;
fUnread := dl;
fNotify := TCheckBox(FindSubView('Noti'));
new(dl);
FailNil(dl);
dl.IDisplayList(TLACSDocument(fDocument),TMessageListView(FindSubView('Read')));
dl.FreeAll;
fRead := dl;
fShow := TTEView(FindSubView('Show'));
fOriginated := TStaticText(FindSubView('Orig'));
fExpires := TStaticText(FindSubView('Expi'));
fForward := TCheckBox(FindSubView('Forw'));
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TMessagesWindow.Free;
{ Free the window. }
var ignore: OSErr;
begin
ignore := NMRemove(QElemPtr(fNotification));
DisposPtr(Ptr(fNotification));
inherited Free;
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TMessagesWindow.KillNotify;
{ Take away the Notification Manager notification. }
var ignore: OSErr;
begin
ignore := NMRemove(QElemPtr(fNotification));
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TMessagesWindow.Notify;
{ Notify the user via the Notification Manager. }
var ignore: OSErr;
begin
{ Only notify if we're in the background and the user wants it. }
if fNotify.IsOn and gInBackground then
begin
ignore := NMRemove(QElemPtr(fNotification));
with fNotification^ do
begin
qType := nmType; { Queue type -- nmType = 8. }
nmMark := 1; { Get mark in Apple menu. }
nmSIcon := GetResource('SICN',kMySmallIcon); { Flashing Icon. }
nmSound := nil; { No sound to be played. }
nmStr := nil; { No alert box. }
nmResp := nil; { No response procedure. }
nmRefCon := 0; { Set to nil since we don't need A5. }
end;
ignore := NMInstall(QElemPtr(fNotification));
end;
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TNewWindow.DoChoice(origView: TView; itsChoice: integer);
{ Handle button hits, etc. }
var ourDoc: TLACSDocument;
f, t: Str32;
h: Handle;
s: Str255;
begin
{ Send Message? }
if origView = fSpread then
begin
{ Ask the user if he's really really sure he wants to post this one. }
if MacAppAlert(phAreYouSure,nil) = kYesButton then
begin
{ Create a new message. }
ourDoc := TLACSDocument(fDocument);
f := ourDoc.fConfig.defaultFilter;
t := ourDoc.fConfig.defaultType;
h := fInput.ExtractText;
{ But only if there's something to say. }
if GetHandleSize(h) > 0 then
begin
FailOSErr(HandToHand(h));
{ Add in the signature. }
fSignature.GetText(s);
if s <> '' then s := Concat(' ',kSignatureSeparator,' ',s);
FailOSErr(PtrAndHand(Ptr(ord4(@s)+1),h,length(s)));
{ Post the message. }
ourDoc.NewMessage(true,f,t,h,GetNow,GetExpire,true);
DisposHandle(h);
{ Clear out the input area. }
fInput.StuffText(NewHandle(0));
fInput.ShowReverted;
end;
end;
end
{ Expiration date change? }
else if (origView = fMonth) or (origView = fDay) then GetSetExpire
{ Otherwise, let the defaults have it. }
else inherited DoChoice(origView,itsChoice);
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
function TNewWindow.DoKeyCommand(ch: char; aKeyCode: integer;
var info: EventInfo): TCommand; override;
{ Handle keyboard events. }
begin
{ Ignore carriage returns. }
if ch = chReturn then DoKeyCommand := gNoChanges
{ Enter is the same as a Send Message click. }
else if ch = chEnter then
begin
DoChoice(fSpread,mButtonHit);
DoKeyCommand := gNoChanges;
end
{ Otherwise, let MacApp do it. }
else DoKeyCommand := inherited DoKeyCommand(ch, aKeyCode, info);
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
function TNewWindow.ExpireExpired: boolean;
{ Check if we need to reset the expiration date. }
var dt: DateTimeRec;
s: Str255;
l, l2: longInt;
begin
{ See if we're into a new day. }
Secs2Date(GetNow+TLACSDocument(fDocument).fConfig.expireIn,dt);
dt.hour := 0;
dt.minute := 0;
dt.second := 0;
Date2Secs(dt,l);
with dt do
begin
fYear.GetText(s);
StringToNum(Copy(s,3,4),l2);
dt.year := l2;
month := fMonth.GetCurrentItem;
day := fDay.GetCurrentItem;
hour := 0;
minute := 0;
second := 0;
end;
Date2Secs(dt,l2);
ExpireExpired := l <> l2;
end;
{--------------------------------------------------------------------------------------------------}
{$S AFields}
procedure TNewWindow.Fields(procedure DoToField(fieldName: Str255; fieldAddr: Ptr;
fieldType: integer)); override;
begin
DoToField('TStatusWindow', nil, bClass);
DoToField('fInput', @fInput, bObject);
DoToField('fSpread', @fSpread, bObject);
DoToField('fMonth', @fMonth, bObject);
DoToField('fDay', @fDay, bObject);
DoToField('fYear', @fYear, bObject);
DoToField('fSignature', @fSignature, bObject);
inherited Fields(DoToField);
end;
{--------------------------------------------------------------------------------------------------}
{$S AInit}
procedure TNewWindow.FindSubviews;
{ Lookup all our subviews for later. }
begin
fInput := TTEView(FindSubView('Inpu'));
fInput.fControlChars := fInput.fControlChars - [chReturn];
fSpread := TButton(FindSubView('Spre'));
fMonth := TPopup(FindSubView('Mont'));
fDay := TPopup(FindSubView('Day '));
fYear := TStaticText(FindSubView('Year'));
fSignature := TStaticText(FindSubView('Sign'));
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
function TNewWindow.GetExpire: longInt;
{ Get the expiration date. }
var dt: DateTimeRec;
l: longInt;
begin
{ Compute the expiration date (remember, we expire at 5AM). }
Secs2Date(GetNow,dt);
with dt do
begin
month := fMonth.GetCurrentItem;
day := fDay.GetCurrentItem;
hour := 5;
minute := 0;
second := 0;
end;
Date2Secs(dt,l);
if (l - GetNow) < 0 then
begin
dt.year := dt.year+1;
Date2Secs(dt,l);
end;
GetExpire := l;
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TNewWindow.GetSetExpire;
{ Get and set the expiration date (corrects for odd month/day combinations, etc. }
begin
SetExpire(GetExpire);
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TNewWindow.GetSignature;
{ Figure out the current signature. }
var ourDoc: TLACSDocument;
s: Str255;
zoneStr: Str32;
begin
ourDoc := TLACSDocument(fDocument);
case ourDoc.fConfig.signature of
kSignatureFromChooser: s := GetString(kChooserName)^^;
kSignatureFromUser: s := ourDoc.fConfig.userSignature;
otherwise s := '';
end;
if s <> '' then
begin
zoneStr := ourDoc.fZoneLooker.fOurZone;
if zoneStr <> '' then s := Concat(s,' @ ',zoneStr);
end;
fSignature.SetText(s,true);
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TNewWindow.ResetExpire;
{ Reset the expiration date display. }
var l: longInt;
dt: DateTimeRec;
begin
Secs2Date(GetNow+TLACSDocument(fDocument).fConfig.expireIn,dt);
Date2Secs(dt,l);
SetExpire(l);
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TNewWindow.ResetIfExpired;
{ Reset the expiration date if the current one is expired. }
begin
if ExpireExpired then ResetExpire;
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TNewWindow.SetExpire(t: longInt);
{ Set the expiration date. }
var dt: DateTimeRec;
s: Str255;
begin
TLACSDocument(fDocument).fConfig.expireIn := t - GetNow;
Secs2Date(t,dt);
NumToString(dt.year,s);
fMonth.SetCurrentItem(dt.month,true);
fDay.SetCurrentItem(dt.day,true);
fYear.SetText(Concat(', ',s),true);
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TStatusWindow.Bored;
{ Change status to "bored and idle..." }
begin
SetStatus(kStatBored);
end;
{--------------------------------------------------------------------------------------------------}
{$S AFields}
procedure TStatusWindow.Fields(procedure DoToField(fieldName: Str255; fieldAddr: Ptr;
fieldType: integer)); override;
var i: integer;
begin
DoToField('TStatusWindow', nil, bClass);
DoToField('fTotalMessages', @fTotalMessages, bObject);
DoToField('fTotalPassed', @fTotalPassed, bObject);
DoToField('fHotMessages', @fHotMessages, bObject);
DoToField('fColdMessages', @fColdMessages, bObject);
for i := 1 to kMaxNodes do
DoToField(Concat('fGossipWith[',LongAsString(i),']'), @fGossipWith[i], bObject);
DoToField('fStatus', @fStatus, bObject);
DoToField('fLastStatusChange', @fLastStatusChange, bLongInt);
inherited Fields(DoToField);
end;
{--------------------------------------------------------------------------------------------------}
{$S AInit}
procedure TStatusWindow.FindSubviews;
{ Lookup all our subviews for later. }
begin
fTotalMessages := TNumberText(FindSubView('Tota'));
fTotalPassed := TNumberText(FindSubView('Pass'));
fHotMessages := TNumberText(FindSubView('HotR'));
fColdMessages := TNumberText(FindSubView('Cold'));
fGossipWith[1] := TStaticText(FindSubView('Gos1'));
fGossipWith[2] := TStaticText(FindSubView('Gos2'));
fGossipWith[3] := TStaticText(FindSubView('Gos3'));
fGossipWith[4] := TStaticText(FindSubView('Gos4'));
fGossipWith[5] := TStaticText(FindSubView('Gos5'));
fGossipWith[6] := TStaticText(FindSubView('Gos6'));
fGossipWith[7] := TStaticText(FindSubView('Gos7'));
fGossipWith[8] := TStaticText(FindSubView('Gos8'));
fGossipWith[9] := TStaticText(FindSubView('Gos9'));
fGossipWith[10] := TStaticText(FindSubView('Gos0'));
fStatus := TStaticText(FindSubView('Stat'));
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TStatusWindow.IncColdMessages(i: integer);
{ Increment the current cold messages count by i. }
begin
fColdMessages.SetValue(fColdMessages.GetValue+i,true);
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TStatusWindow.IncHotMessages(i: integer);
{ Increment the current hot messages count by i. }
begin
fHotMessages.SetValue(fHotMessages.GetValue+i,true);
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TStatusWindow.IncTotalPassed(i: integer);
{ Increment the total messages passed on count by i. }
begin
fTotalPassed.SetValue(fTotalPassed.GetValue+i,true);
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TStatusWindow.IncTotalMessages(i: integer);
{ Increment the total messages seen count by i. }
begin
fTotalMessages.SetValue(fTotalMessages.GetValue+i,true);
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TStatusWindow.SetStatus(statNum: integer);
{ Change the status display. }
var s: Str255;
begin
fLastStatusChange := TickCount;
GetIndString(s,kStatStrings,statNum);
fStatus.SetText(s,true);
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TStatusWindow.UpdateGossipWith;
{ Update the display of who we're gossiping with. }
var i: integer;
n1: EntityName;
nodeLooker: TNodeLookup;
begin
nodeLooker := TLACSDocument(fDocument).fNodeLooker;
for i := 1 to nodeLooker.fNodeCount do
begin
n1 := nodeLooker.fNodes[i];
with n1 do
if zoneStr = '*' then fGossipWith[i].SetText(objStr,true)
else fGossipWith[i].SetText(Concat(objStr,' @ ',zoneStr),true);
end;
for i := nodeLooker.fNodeCount + 1 to kMaxNodes do fGossipWith[i].SetText('',true);
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
function TMessageListView.DoMouseCommand(var theMouse: Point; var info: EventInfo;
var hysteresis: Point): TCommand;
{ Handle mouse events. }
var aRow, aCol: integer;
r: TMessage;
begin
DoMouseCommand := gNoChanges;
{ Make sure this is a reasonable place to click. }
if IdentifyPoint(theMouse, aRow, aCol) <> badChoice then
begin
if aRow <= fList.fSize then
begin
{ Get the corresponding message. }
r := TMessage(fList.At(aRow));
{ Mark it as read, in case it isn't already. }
r.MarkAsRead;
{ Display the full text. }
fList.fDocument.fMessagesWindow.DisplayMessage(r);
end;
end;
end;
{--------------------------------------------------------------------------------------------------}
{$S AFields}
procedure TMessageListView.Fields(procedure DoToField(fieldName: Str255; fieldAddr: Ptr;
fieldType: integer)); override;
begin
DoToField('TMessageListView', nil, bClass);
DoToField('fList', @fList, bObject);
inherited Fields(DoToField);
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TMessageListView.GetItemText(anItem: integer; var aString: Str255);
{ Retrieve the text for a particular item. }
var r: TMessage;
begin
r := TMessage(fList.At(anItem));
if r = nil then aString := 'No items available...'
else r.AsString(aString);
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TPeriodic.Activate;
{ Start a periodic activity. }
begin
{ To be filled in by a subclass. }
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
function TPeriodic.DoIdle(phase: IdlePhase): boolean;
{ Internal method -- idle the object. }
var fi: FailInfo;
procedure hdlFailure(error: OSErr; message: LongInt);
{ If we fail, reset to inactive. }
begin
fState := kPeriodicInactive;
fIdleFreq := fInactiveIdle;
exit(DoIdle);
end;
begin
DoIdle := false;
if phase = IdleContinue then
begin
CatchFailures(fi,hdlFailure);
{ If we've just timed out, then activate the object. }
if fState = kPeriodicInactive then Activate
else
begin
{ If we're waiting, see if we're done yet. }
if fState = kPeriodicWaiting then Waiting;
{ If we're done, do something with the results. }
if fState = kPeriodicActive then DoIt;
end;
{ Figure out the new idle frequency. }
if fState = kPeriodicInactive then fIdleFreq := fInactiveIdle
else fIdleFreq := fActiveIdle;
Success(fi);
end;
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TPeriodic.DoIt;
{ Handle the results of an async operation. }
begin
{ To be filled in by a subclass. }
end;
{--------------------------------------------------------------------------------------------------}
{$S AFields}
procedure TPeriodic.Fields(procedure DoToField(fieldName: Str255; fieldAddr: Ptr;
fieldType: integer)); override;
var s: Str255;
begin
DoToField('TPeriodic', nil, bClass);
DoToField('fInactiveIdle', @fInactiveIdle, bLongInt);
DoToField('fActiveIdle', @fActiveIdle, bLongInt);
if fState = kPeriodicInactive then s := 'kPeriodicInactive'
else if fState = kPeriodicWaiting then s := 'kPeriodicWaiting'
else s := 'kPeriodicActive';
DoToField('fState', @s, bString);
inherited Fields(DoToField);
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TPeriodic.Free;
{ Free the object. }
begin
{ First wait for any outstanding operation to complete. }
while fState = kPeriodicWaiting do Waiting;
{ Deinstall ourselves from the co-handler chain. }
gApplication.InstallCohandler(self,false);
{ Free ourselves. }
inherited Free;
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TPeriodic.IPeriodic(initialIdle, inactiveIdle, activeIdle: longInt);
{ Initialize the object. }
begin
IEvtHandler(nil);
fIdleFreq := initialIdle;
fInactiveIdle := inactiveIdle;
fActiveIdle := activeIdle;
fState := kPeriodicInactive;
{ Install the object in the co-handler chain. }
gApplication.InstallCohandler(self,true);
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TPeriodic.Kick;
{ Start things up even if it isn't normally time yet. }
begin
fIdleFreq := 0;
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TPeriodic.Waiting;
{ Test for async completion. }
begin
{ To be filled in by a subclass. }
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TPssst.Activate;
{ Update the about box. }
var ignore: OSErr;
procedure psstIt(i: TIcon);
{ Update one icon. }
begin
{ Only do it if we've got the right kind of view. }
if Member(i,TIcon) then
begin
{ Toggle randomly between "pssst" and no "pssst". }
if (i.fRsrcID = kPsstHead) and (BAnd(Random,63) = 0) then
begin
i.SetIcon(GetIcon(kNoPsstHead),true);
i.fRsrcID := kNoPsstHead;
end
else if (i.fRsrcID = kNoPsstHead) and (BAnd(Random,63) = 0) then
begin
i.SetIcon(GetIcon(kPsstHead),true);
i.fRsrcID := kPsstHead;
end;
end;
end;
begin
{ For each balloon, update the view. }
if gAboutWindow.IsShown then gAboutWindow.EachSubView(psstIt);
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TMessagesExpirator.Activate;
{ Expire messages. }
begin
{ First, kill of notify if present. }
if not gInBackground then fDocument.fMessagesWindow.KillNotify;
{ Second, reset the expiration date in the New window. }
fDocument.fNewWindow.ResetIfExpired;
{ Third, expire messages. }
fDocument.ExpireMessages;
{ Forth, if enough time has gone by, reset status to "bored and idle..." }
if (TickCount-fDocument.fStatusWindow.fLastStatusChange) > kStatusBoredRate then
fDocument.fStatusWindow.Bored;
end;
{--------------------------------------------------------------------------------------------------}
{$S AFields}
procedure TMessagesExpirator.Fields(procedure DoToField(fieldName: Str255; fieldAddr: Ptr;
fieldType: integer)); override;
begin
DoToField('TMessagesExpirator', nil, bClass);
DoToField('fDocument', @fDocument, bObject);
inherited Fields(DoToField);
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TMessagesExpirator.IMessagesExpirator(aDoc: TLACSDocument;
initialIdle, inactiveIdle, activeIdle: longInt);
{ Initialize message expirer. }
begin
IPeriodic(initialIdle,inactiveIdle,activeIdle);
fDocument := aDoc;
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TDocumentSaver.Activate;
{ Get ready to save. }
begin
fState := kPeriodicWaiting;
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TDocumentSaver.DoIt;
{ Save the document. }
begin
fDocument.Save(cSave,false,false);
fState := kPeriodicInactive;
end;
{--------------------------------------------------------------------------------------------------}
{$S AFields}
procedure TDocumentSaver.Fields(procedure DoToField(fieldName: Str255; fieldAddr: Ptr;
fieldType: integer)); override;
begin
DoToField('TDocumentSaver', nil, bClass);
DoToField('fDocument', @fDocument, bObject);
inherited Fields(DoToField);
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TDocumentSaver.IDocumentSaver(aDoc: TLACSDocument;
initialIdle, inactiveIdle, activeIdle: longInt);
{ Initialize the document saver. }
begin
IPeriodic(initialIdle,inactiveIdle,activeIdle);
fDocument := aDoc;
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TDocumentSaver.Waiting;
{ Wait until we're in the foreground. }
begin
if not gInBackground then fState := kPeriodicActive;
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TZoneLookup.Activate;
{ Start a zone list lookup. }
var addrBlock: AddrBlock;
ignore: integer;
s: Str255;
begin
{ Let the user know what we're doing. }
fDocument.fStatusWindow.SetStatus(kStatZoneUpdate);
{ Clear out the zone list. }
fZoneCount := 0;
{ Get our zone name. }
with fXPPPBPtr^ do
begin
ioRefNum := xppRefNum; { Driver refNum -41. }
csCode := xCall;
xppSubCode := zipGetMyZone;
zipBuffPtr := @s;
zipInfoField[1] := 0; { ALWAYS 0. }
zipInfoField[2] := 0; { ALWAYS 0. }
end;
{ Send the getMyZone request synchronously (and cross our electronic fingers it doesn't take long). }
if PBControl(ParmBlkPtr(fXPPPBPtr), false) <> noErr then fState := kPeriodicInactive
else
begin
{ Update the display to reflect any changes. }
if (s <> fOurZone) and (s <> '') then
begin
fOurZone := s;
fDocument.fNewWindow.GetSignature;
end;
{ Now make a getZoneList request. }
with fXPPPBPtr^ do
begin
zipInfoField[1] := 0; { ALWAYS 0 on first call; contains state info on subsequent calls. }
zipInfoField[2] := 0; { ALWAYS 0 on first call; contains state info on subsequent calls. }
ioRefNum := XPPRefNum; { Driver refNum -41. }
csCode := xCall;
xppSubCode := zipGetZoneList;
xppTimeOut := kXPPTimeOutVal;
xppRetry := kXPPRetryCount;
zipBuffPtr := Ptr(fZonesBuffer); { This buffer will be filled with packed zone names. }
zipLastFlag := 0;
end;
{ Send off the request. }
ignore := PBControl(ParmBlkPtr(fXPPPBPtr), true);
fState := kPeriodicWaiting;
end;
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TZoneLookup.DoIt;
{ Process returned zone list. }
var dCount: integer;
dCurr: Ptr;
ignore: OSErr;
begin
{ Cycle through the returned list. }
dCount := fXPPPBPtr^.zipNumZones; { Find out how many returned. }
dCurr := fZonesBuffer; { Put current pointer at start. }
while (fZoneCount < kMaxZones) and (dCount > 0) do { Get each zone. }
begin
fZoneCount := fZoneCount+1;
fZones[fZoneCount][0] := chr(dCurr^);
BlockMove(pointer(ord4(dCurr)+1),pointer(ord4(@fZones[fZoneCount])+1),dCurr^);
dCurr := pointer(ord4(dCurr) + dCurr^+1); { Bump up current pointer. }
dCount := dCount-1;
end;
{ If there are more to come, do another request. }
if (fZoneCount < kMaxZones) and (fXPPPBPtr^.zipLastFlag = 0) then
begin
ignore := PBControl(ParmBlkPtr(fXPPPBPtr), true);
fState := kPeriodicWaiting;
end
{ Otherwise, we're all done. }
else fState := kPeriodicInactive;
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
function TZoneLookup.GetRandomZone: Str32;
{ Pick a random zone from the list and return it. }
begin
{ If there are no zones in the list, then return the local zone. }
if (fZoneCount = 0) or ((abs(Random) mod fDocument.fConfig.inZoneSearch) = 0) then GetRandomZone := '*'
{ Otherwise, return a random zone from the zone list. }
else GetRandomZone := fZones[abs(Random) mod fZoneCount + 1];
end;
{--------------------------------------------------------------------------------------------------}
{$S AFields}
procedure TZoneLookup.Fields(procedure DoToField(fieldName: Str255; fieldAddr: Ptr;
fieldType: integer)); override;
var p: Ptr;
begin
DoToField('TZoneLookup', nil, bClass);
DoToField('fDocument', @fDocument, bObject);
DoToField('fZoneCount', @fZoneCount, bInteger);
DoToField('fXPPPBPtr', @fXPPPBPtr, bPointer);
DoToField('fZonesBuffer', @fZonesBuffer, bPointer);
DoToField('fOurZone',@fOurZone,bString);
p := @fZones;
DoToField('fZones', @p, bPointer);
inherited Fields(DoToField);
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TZoneLookup.Free;
{ Free the zone lookup object. }
begin
DisposPtr(Ptr(fXPPPBPtr));
DisposPtr(fZonesBuffer);
inherited Free;
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TZoneLookup.IZoneLookup(aDoc: TLACSDocument; initialIdle, inactiveIdle, activeIdle: longInt);
{ Initialize the zone lookup object. }
begin
IPeriodic(initialIdle,inactiveIdle,activeIdle);
fDocument := aDoc;
fOurZone := '';
fZoneCount := 0;
{ Allocate memory blocks we'll need later. }
fXPPPBPtr := xCallPtr(NewPtr(sizeof(xCallParam)));
FailNil(fXPPPBPtr);
fZonesBuffer := NewPtr(kZonesBufferSize);
FailNil(fZonesBuffer);
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TZoneLookup.Waiting;
{ Wait for the zone lookup to complete. }
begin
if fXPPPBPtr^.ioResult = noErr then fState := kPeriodicActive
else if fXPPPBPtr^.ioResult < noErr then fState := kPeriodicInactive;
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TNodeLookup.Activate;
{ Start a node lookup. }
var addrBlock: AddrBlock;
ignore: integer;
theZone: Str32;
begin
{ Let the user know what's going on. }
fDocument.fStatusWindow.SetStatus(kStatNodeUpdate);
{ Pick a zone to look in. }
theZone := fDocument.fZoneLooker.GetRandomZone;
fZone := theZone;
{ Build a lookup request. }
NBPSetEntity(fNameBuffer,'=',kLACS,theZone);
with fpBlock^ do
begin
ioCompletion := nil;
interval := kNBPTimeOutVal;
count := kNBPRetryCount;
entityPtr := fNameBuffer;
retBuffPtr := fLookupBuf;
retBuffSize := kLookupBufferSize;
maxToGet := kMaxLookupNames;
numGotten := 0;
end;
{ Do the lookup. }
ignore := PLookupName(fpBlock,true);
fState := kPeriodicWaiting;
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TNodeLookup.DoIt;
{ Process the results of a node lookup. }
var doNodeUpdate: boolean;
doShortNodeUpdate: boolean;
name: EntityName;
addr: AddrBlock;
i: integer;
begin
{ Check if we got any results at all. }
if fpBlock^.numGotten > 0 then
begin
{ If so, get the name. }
FailOSErr(NBPExtract(fLookupBuf,fpBlock^.numGotten,abs(Random) mod fpBlock^.numGotten + 1,
name,addr));
{ Get the zone from our own records. }
name.zoneStr := fZone;
doNodeUpdate := true;
{ Check if we've found ourselves. }
if (name.objStr = GetString(kChooserName)^^) and (name.zoneStr = '*') then doNodeUpdate := false
{ Otherwise, check if we've found a node we already had in the list. }
else
for i := 1 to fNodeCount do
if (name.objStr = fNodes[i].objStr) and (name.zoneStr = fNodes[i].zoneStr) then
begin
doNodeUpdate := false;
leave;
end;
{ If we've really got a new node to add in... }
if doNodeUpdate then
begin
{ Figure out where to add it (extend the list or replace an existing entry). }
if fNodeCount < kMaxNodes then
begin
fNodeCount := fNodeCount + 1;
i := fNodeCount;
end
else i := abs(Random) mod kMaxNodes + 1;
{ Save the new node. }
fNodes[i] := name;
fAddrs[i] := addr;
{ Update the display for the user. }
fDocument.fStatusWindow.UpdateGossipWith;
end;
end;
{ Decide if we should be doing a short or long time-out. }
doShortNodeUpdate := false;
if fNodeCount = 0 then doShortNodeUpdate := true
else
begin
doShortNodeUpdate := true;
for i := 1 to fNodeCount do
if fNodes[i].zoneStr <> '*' then doShortNodeUpdate := false;
end;
{ Set up the new time-out. }
if doShortNodeUpdate then fInactiveIdle := fFastIdle
else fInactiveIdle := fSlowIdle;
fState := kPeriodicInactive;
end;
{--------------------------------------------------------------------------------------------------}
{$S AFields}
procedure TNodeLookup.Fields(procedure DoToField(fieldName: Str255; fieldAddr: Ptr;
fieldType: integer)); override;
var p: Ptr;
begin
DoToField('TNodeLookup', nil, bClass);
DoToField('fDocument', @fDocument, bObject);
DoToField('fSlowIdle', @fSlowIdle, bLongInt);
DoToField('fFastIdle', @fFastIdle, bLongInt);
DoToField('fNodeCount', @fNodeCount, bInteger);
DoToField('fNameBuffer', @fNameBuffer, bPointer);
DoToField('fZone', @fZone, bString);
DoToField('fpBlock', @fpBlock, bPointer);
p := @fNodes;
DoToField('fNodes', @p, bPointer);
p := @fAddrs;
DoToField('fAddrs', @p, bPointer);
inherited Fields(DoToField);
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TNodeLookup.Free;
{ Free the node lookup object. }
begin
{ Free our buffers and IO blocks. }
DisposPtr(fNameBuffer);
DisposPtr(Ptr(fpBlock));
DisposPtr(fLookupBuf);
{ Free ourself. }
inherited Free;
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
function TNodeLookup.GetRandomNode(var addr: AddrBlock): boolean;
{ Pick a random node from the list and return it. GetRandomNode itself returns true if we had a node to return. }
var i: integer;
begin
GetRandomNode := false;
{ It only works if there are any nodes to pick from. }
if fNodeCount > 0 then
begin
{ Pick a node to return. }
i := abs(Random) mod fNodeCount + 1;
{ Build a confirm query. }
with fpBlock^ do
begin
ioCompletion := nil;
interval := kNBPTimeOutVal;
count := kNBPRetryCount;
with fNodes[i] do NBPSetEntity(fNameBuffer,objStr,typeStr,zoneStr);
entityPtr := fNameBuffer;
confirmAddr := fAddrs[i];
addr := confirmAddr;
end;
{ Confirm that the node's still there. }
if PConfirmName(fpBlock,false) = noErr then GetRandomNode := true
{ Otherwise, remove it form the list. }
else
begin
BlockMove(Ptr(ord4(@fNodes)+i*sizeof(EntityName)),
Ptr(ord4(@fNodes)+(i-1)*sizeof(EntityName)),
(fNodeCount-i)*sizeof(EntityName));
BlockMove(Ptr(ord4(@fAddrs)+i*sizeof(AddrBlock)),
Ptr(ord4(@fAddrs)+(i-1)*sizeof(AddrBlock)),
(fNodeCount-i)*sizeof(AddrBlock));
fNodeCount := fNodeCount-1;
fDocument.fStatusWindow.UpdateGossipWith;
end;
end;
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TNodeLookup.INodeLookup(aDoc: TLACSDocument; initialIdle, fastIdle, slowIdle, activeIdle: longInt);
{ Initialize the node lookup object. }
begin
IPeriodic(initialIdle,slowIdle,activeIdle);
fDocument := aDoc;
fSlowIdle := slowIdle;
fFastIdle := fastIdle;
fNodeCount := 0;
{ Allocate buffers and IO blocks for later. }
fNameBuffer := NewPtr(100);
FailNil(fNameBuffer);
fpBlock := MPPPBPtr(NewPtr(sizeof(MPPParamBlock)));
FailNil(fpBlock);
fLookupBuf := NewPtr(kLookupBufferSize);
FailNil(fLookupBuf);
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TNodeLookup.Waiting;
{ Wait for a node lookup to complete. }
begin
if fpBlock^.ioResult = noErr then fState := kPeriodicActive
else if fpBlock^.ioResult < noErr then fState := kPeriodicInactive;
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TGossip.Activate;
{ Start a new gossip session (outgoing only). }
var addr: AddrBlock;
r: TMessage;
ignore: OSErr;
begin
{ Only initiate a session if we're outgoing -- actually, Activate should never get called if we're not, but,
hey, I'm paranoid, what can I tell ya? }
fState := kPeriodicInactive;
if fOutgoing then
begin
{ Get a node to gossip with. }
if fDocument.fNodeLooker.GetRandomNode(addr) then
begin
{ Let the user know what's happening. }
fDocument.fStatusWindow.SetStatus(kStatGossiping);
{ Get a message to spread. }
r := fDocument.GetHotMessage;
if r <> nil then
if not r.fForward then r := nil;
{ Decide if we have anything to spread or not. }
if fDocument.fConfig.pull or (r <> nil) or (fDocument.fConfig.pullOnLess > fDocument.fMessages.fSize) then
begin
{ Build an ADSP session open request. }
with fADSP^ do
begin
{ Issue an active open command. }
remoteAddress := addr;
filterAddress := AddrBlock(0);
ocMode := ocRequest;
ocInterval := 0;
ocMaximum := 0;
csCode := dspOpen;
end;
{ Open an ADSP session. }
ignore := PBControl(ParmBlkPtr(fADSP),true);
fDidPull := false;
fState := kPeriodicWaiting;
end;
end;
end;
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TGossip.DoIt;
{ Handle new input. }
var r: TMessage;
p: Ptr;
noGood: boolean;
begin
noGood := false;
{ If this is a session open and we're the initiator... }
if (fADSP^.csCode = dspOpen) and fOutgoing then
begin
{ Get a message to send. }
r := fDocument.GetHotMessage;
if r <> nil then
if not r.fForward then r := nil;
{ Decide if we've something worth sending. }
if fDocument.fConfig.pull or (r <> nil) or (fDocument.fConfig.pullOnLess > fDocument.fMessages.fSize) then
begin
{ Generate the appropriate send request. }
with fADSP^ do
begin
p := fADSPData;
if fDocument.fConfig.pullOnLess > fDocument.fMessages.fSize then reqCount := BuildPullCold(p)
else if fDocument.fConfig.pull then
begin
reqCount := BuildPull(p);
fDidPull := true;
end
else reqCount := r.BuildMessageCommand(p);
dataPtr := fADSPData;
eom := 1;
flush := 1;
csCode := dspWrite;
end;
{ Send it. }
if PBControl(ParmBlkPtr(fADSP),true) <> noErr then noGood := true;
end
else noGood := true;
end
{ If this is a completed read... }
else if fADSP^.csCode = dspRead then
begin
{ Handle the incoming command, and build a reply if approriate. }
with fADSP^ do
begin
reqCount := fDocument.HandleIncomingCommand(fADSPData,fADSP^.actCount);
if (reqCount = 0) and fOutgoing and (not fDidPull) then
begin
reqCount := BuildPull(fADSPData);
fDidPull := true;
end;
dataPtr := fADSPData;
eom := 1;
flush := 1;
csCode := dspWrite;
end;
{ If there's a reply, send it. }
if fADSP^.reqCount > 0 then
begin
if PBControl(ParmBlkPtr(fADSP),true) <> noErr then noGood := true;
end
else noGood := true;
end
{ Otherwise... }
else
begin
{ Start up a receive. }
with fADSP^ do
begin
dataPtr := fADSPData;
reqCount := kADSPMaxCommand;
csCode := dspRead;
end;
if PBControl(ParmBlkPtr(fADSP),true) <> noErr then noGood := true;
end;
{ If we're all done, reset the connection. }
if noGood then ResetConnection
{ Otherwise, wait for the results. }
else fState := kPeriodicWaiting;
end;
{--------------------------------------------------------------------------------------------------}
{$S AFields}
procedure TGossip.Fields(procedure DoToField(fieldName: Str255; fieldAddr: Ptr;
fieldType: integer));
begin
DoToField('TGossip', nil, bClass);
DoToField('fDocument', @fDocument, bObject);
DoToField('fOutgoing', @fOutgoing, bBoolean);
DoToField('fDidPull', @fDidPull, bBoolean);
DoToField('fADSPSocket', @fADSPSocket, bInteger);
DoToField('fADSP', @fADSP, bPointer);
DoToField('fCcbPtr', @fCcbPtr, bPointer);
DoToField('fSendQueue', @fSendQueue, bPointer);
DoToField('fRecvQueue', @fRecvQueue, bPointer);
DoToField('fAttnPtr', @fAttnPtr, bPointer);
DoToField('fADSPData', @fADSPData, bPointer);
DoToField('fNTE', @fNTE, bPointer);
inherited Fields(DoToField);
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TGossip.Free;
{ Free the gossip object. }
var pBlock: MPPParamBlock;
io: DSPParamBlock;
ignore: OSErr;
begin
{ Remove the names table entry. }
if not fOutgoing then
begin
pBlock.entityPtr := Ptr(ord4(@fNTE^.nteData)+1);
ignore := PRemoveName(@pBlock,false);
end;
{ Get rid of the ADSP connection. }
io := fADSP^;
io.abort := 1;
io.csCode := dspRemove;
ignore := PBControl(@io,false);
{ Dispose our buffers and IO blocks. }
DisposPtr(fCcbPtr);
DisposPtr(fSendQueue);
DisposPtr(fRecvQueue);
DisposPtr(fAttnPtr);
DisposPtr(Ptr(fADSP));
DisposPtr(fADSPData);
fState := kPeriodicInactive;
inherited Free;
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TGossip.IGossip(aDoc: TLACSDocument; outgoing: boolean; initialIdle, inactiveIdle, activeIdle: longInt);
{ Initialize the gossip object. }
var pBlock: MPPParamBlock;
s: Str255;
begin
IPeriodic(initialIdle,inactiveIdle,activeIdle);
fDocument := aDoc;
fOutgoing := outgoing;
{ Allocate buffers and IO blocks. }
fADSP := DSPPBPtr(NewPtr(sizeof(DSPParamBlock)));
FailNil(fADSP);
fADSPData := NewPtr(kADSPMaxCommand);
FailNil(fADSPData);
{ Fill in the ADSP IO block. }
with fADSP^ do
begin
ioCRefNum := gADSP;
ioCompletion := nil;
ccbPtr := TPCCB(NewPtr(sizeof(TRCCB)));
FailNil(ccbPtr);
fCcbPtr := Ptr(ccbPtr);
userRoutine := nil;
sendQSize := kADSPSendBufSize;
sendQueue := NewPtr(kADSPSendBufSize);
FailNil(sendQueue);
fSendQueue := sendQueue;
recvQSize := kADSPRecvBufSize;
recvQueue := NewPtr(kADSPRecvBufSize);
FailNil(recvQueue);
fRecvQueue := recvQueue;
attnPtr := NewPtr(attnBufSize);
FailNil(attnPtr);
fAttnPtr := attnPtr;
localSocket := 0;
csCode := dspInit;
end;
FailOSErr(PBControl(ParmBlkPtr(fADSP),false));
fADSPSocket := fADSP^.localSocket;
{ If we're incoming, do a passive open and register us on NBP. }
if not fOutgoing then
begin
PassiveOpen;
fNTE := Pointer(NewPtr(sizeof(NamesTableEntry)));
FailNil(fNTE);
s := GetString(kChooserName)^^;
NBPSetNTE(Ptr(fNTE),s,kLACS,'*',fADSPSocket);
with pBlock do
begin
interval := kNBPTimeOutVal;
count := kNBPRetryCount;
entityPtr := Ptr(fNTE);
verifyFlag := 1;
end;
FailOSErr(PRegisterName(@pBlock,false));
end;
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TGossip.PassiveOpen;
{ Do a passive connection open. }
var ignore: OSErr;
begin
{ Build an ADSP passive open request. }
with fADSP^ do
begin
{ Issue a passive open command. }
ioCompletion := nil;
filterAddress := AddrBlock(0);
ocMode := ocPassive;
ocInterval := 0;
ocMaximum := 0;
csCode := dspOpen;
end;
{ Open it. }
ignore := PBControl(ParmBlkPtr(fADSP),true);
fState := kPeriodicWaiting;
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TGossip.ResetConnection;
{ Reset the connection. }
var ignore: OSErr;
begin
{ Build an ADSP close connection request. }
with fADSP^ do
begin
abort := 0;
csCode := dspClose;
end;
{ Close the connection. }
ignore := PBControl(ParmBlkPtr(fADSP),false);
{ Then reopen a listen if we're doing input, or reset to timing out if we're doing output. }
if not fOutgoing then PassiveOpen
else fState := kPeriodicInactive;
end;
{--------------------------------------------------------------------------------------------------}
{$S ARes}
procedure TGossip.Waiting;
{ Wait for more input or a connection to open. }
var ignore: OSErr;
begin
{ We've got something if the operation has completed, and it isn't a zero-length read. }
if (fADSP^.ioResult = noErr) and ((fADSP^.csCode <> dspRead) or (fADSP^.actCount <> 0)) then
begin
if not fOutgoing then fDocument.fStatusWindow.SetStatus(kStatIncomingConnect);
fState := kPeriodicActive;
end
else if fADSP^.ioResult <= noErr then ResetConnection;
end;